Aminet 28/Aminet 28 (1998)(GTI - Schatztruhe)[!][Dec 1998].iso/Aminet/util/rexx/FWCalendar.lha/FWCalendar/FWCalendar.rexx

OS/2 REXX Batch file | 1998-09-30 | 18.5 KB | 592 lines

/*
   Calendar Macro
   Creates calendars on FinalWriter4 (SoftWood)
   Written by Ronald Goertz
   based on a program by Andrew McCardie
   $VER: Calendar v2.15 (26 Sep 98)
*/

OPTIONS RESULTS
address FINALW.1
parse arg opt

if exists('LIBS:rexxtricks.library') then do
  call addlib('rexxtricks.library', 0, -30, 0)
  RexxTricks = 1
end
call addlib('rexxreqtools.library', 0, -30, 0)

ClearDoc
if result == 0 then exit
GetDocItemPrefs Decimal; DecimalFormat = result
DocItemPrefs Decimal Period
PageSetup ORIENT Wide

call SetVariables

CalType = rtezrequest('Monthly calendar or Whole-year summary?','Monthly|Whole Year|Cancel',,'rt_reqpos=reqpos_centerscr')
if CalType == 0 then exit

if CalType == 2 then do
  Year = SUBSTR(DATE('S'),1,4)
  EnteredYear = rtgetstring(Year, 'Enter year:', 'Year Select', 'OK|Cancel', 'rt_reqpos=reqpos_centerscr', 'UserChoice')
  if UserChoice == 0 | EnteredYear == "" then do
    if upper(DecimalFormat) = 'COMMA' then DocItemPrefs Decimal Comma
    Exit 10
  end

  View 20
  TextBlockTypePrefs SIZE FYMiniCalFSize COLOR BlackName
  BoxPrefs LINEWT Hairline LINECOLOR BlackName FILL Transparent
  DrawTextBlock 1 1 1 "1"; ID = RESULT
  Redraw
  GetObjectCoords ID; parse var RESULT . . . WidthOf1 .
  DeleteObject ID

  Year = EnteredYear
  CalTop = TopMargin
  do r = 0 to 3
    TopMargin = CalTop + r * (7*FYMiniCalFontHeight + MiniCalVSpacing)
    do c = 0 to 2
      Month = r * 3 + c + 1
      Mn = right(Month, 2, '0')
      TempDate = Year''Mn'01'
      if (Year//4 == 0 & Year//100 > 0) | Year//400 == 0 Then MonthLength.2 = 29
      interpret "StartDate = Day."Date('W', TempDate, 'S')
      call DrawMiniCal(0, FYMiniCalWidth, FYMiniCalFontHeight)
    end
  end
  selectobject
  view 75
  if upper(DecimalFormat) = 'COMMA' then DocItemPrefs Decimal Comma
  exit
end

if RexxTricks == 1 then do
  CalMonth = getenv('CalMonth')
  if CalMonth == '' then CalMonth = ThisMonth
  else do
    CalMonth = CalMonth + 1
    if CalMonth = 13 then CalMonth = 1
  end
end
else CalMonth = ThisMonth

MonthName = rtgetstring(Month.CalMonth, 'Enter month:', 'Month Select', 'OK|Cancel', 'rt_reqpos=reqpos_centerscr', 'UserChoice')
Month = ConvertMonth(MonthName)
if UserChoice == 0 | MonthName == "" | Month = 0 then do
  if upper(DecimalFormat) = 'COMMA' then DocItemPrefs Decimal Comma
  call rtezrequest('Month name not recognized.',,,'rt_reqpos=reqpos_centerscr')
  Exit 10
end
Mn = right(Month, 2, '0')
PrevMonth = Month - 1; if PrevMonth = 0 then PrevMonth = 12
if RexxTricks == 1 then call setenv('CalMonth', Month)

Year = SUBSTR(DATE('S'),1,4)
if Month < ThisMonth then Year = Year + 1

EnteredYear = rtgetstring(Year, 'Enter year:', 'Year Select', 'OK|Cancel', 'rt_reqpos=reqpos_centerscr', 'UserChoice')
if UserChoice == 0 | EnteredYear = "" then do
  if upper(DecimalFormat) = 'COMMA' then DocItemPrefs Decimal Comma
  Exit 10
end

call SetHighLights

/* Finally, the program */
View 20
Year = EnteredYear
TempDate = Year''Mn'01'

if (Year//4 == 0 & Year//100 > 0) | Year//400 == 0 Then MonthLength.2 = 29

interpret "StartDate = Day."Date('W', TempDate, 'S')

TextBlockTypePrefs SIZE 4 COLOR WhiteName
DrawTextBlock 1 0 0 TempDate /* Object ID == 2, only required for AddEvent macro, MUST be drawn first  */
DrawTextBlock 1 0 0 Margins  /* Object ID == 3, only required for AddEvent macro, MUST be drawn second */

/* Draw dates and optional highlights */
Day = - StartDate
LineTop.    = CalTop
LineBottom. = CalTop + BoxHeight*5
LineLeft.   = LeftMargin
LineRight.  = CalRight

TextBlockTypePrefs WIDTH DateFWidth FONT DateFont
Do i = 0 to 5
  if i = 5 then do
    BoxTop = CalTop + BoxHeight*4.5
    BHeight = BoxHeight/2
  end
  else do
    BoxTop  = CalTop + BoxHeight*i
    BHeight = BoxHeight
  end

  Do j = 0 to 6
    Day = Day + 1
    BoxLeft = LeftMargin + BoxWidth * j
    If (Day < 1) | (Day > MonthLength.Month) then do
      if Day < 1 then do
        PrintDay = MonthLength.PrevMonth + Day
        LineTop.j = CalTop + BoxHeight
        LineLeft.0 = LeftMargin + BoxWidth * (j + 1)
      end
      else do
        PrintDay = Day - MonthLength.Month
        interpret "LineBottom."j+1" = "CalTop + BoxHeight*4
        CalRow = i + 1
        if LineRight.CalRow == CalRight then LineRight.CalRow = LeftMargin + BoxWidth * j
      end
      if Extended then Do
        TextBlockTypePrefs SIZE DateFSize COLOR ExtendedColor
        DrawTextBlock 1 (BoxLeft + DateOffset) (BoxTop + DateDown) PrintDay
      End
    End
    else do
      if i = 5 then DrawLine 1 BoxLeft BoxTop (BoxLeft + BoxWidth) BoxTop
      if (j = 0 | j = 6) & (symbol('WeekendColor') == 'VAR') then do
        BoxPrefs LINEWT None FILL Solid FILLCOLOR WeekendColor
        DrawBox 1 BoxLeft BoxTop BoxWidth BHeight
      end
      if symbol('Highlight.Month.Day') == 'VAR' then do
        if right(Highlight.Month.Day, 1) == '#' then do
          TextBlockTypePrefs SIZE HighlightFSize WIDTH HighlightFWidth COLOR HighlightFColorB
          if symbol('HighlightColorB') == 'VAR' then do
            BoxPrefs LINEWT None FILL Solid FILLCOLOR HighlightColorB
            DrawBox 1 BoxLeft BoxTop BoxWidth BHeight
          end
        end
        else do
          TextBlockTypePrefs SIZE HighlightFSize WIDTH HighlightFWidth COLOR HighlightFColorNB
          if symbol('HighlightColorNB') == 'VAR' then do
            BoxPrefs LINEWT None FILL Solid FILLCOLOR HighlightColorNB
            DrawBox 1 BoxLeft BoxTop BoxWidth BHeight
          end
        end
        TextLeft   = (BoxLeft + DateOffset) + HighlightOffset
        TextBottom = (BoxTop + DateDown - (DateFontHeight - HighlightFontHeight)/2)
        DrawTextBlock 1 TextLeft TextBottom compress(Highlight.Month.Day,'#')
      End
      else TextBlockTypePrefs COLOR DateFColor
      TextBlockTypePrefs SIZE DateFSize
      DrawTextBlock 1 (BoxLeft + DateOffset) (BoxTop + DateDown) Day
    End
    if (i = 5) & (Day = MonthLength.Month) then leave i
  End
  if Day >= MonthLength.Month then leave
End
LowRow = i
if LowRow = 3 then LineBottom. = CalTop + BoxHeight*4

/* Draw vertical grid */
do i = 0 to 7
  LeftEdge = LeftMargin + BoxWidth*i
  if Extended then do
    LinePrefs LINECOLOR ExtendedColor
    if LineTop.i > CalTop then DrawLine 1 LeftEdge CalTop LeftEdge LineTop.i
    if LineBottom.i < LineBottom.8 then DrawLine 1 LeftEdge LineBottom.i LeftEdge LineBottom.8
  end
  LinePrefs LINECOLOR GridColor
  DrawLine 1 LeftEdge LineTop.i LeftEdge LineBottom.i
end

/* Draw horizontal grid */
do i = 0 to min(LowRow + 1, 5)
  TopEdge = CalTop + BoxHeight * i
  if Extended then do
    LinePrefs LINECOLOR ExtendedColor
    if LineLeft.i > LeftMargin then DrawLine 1 LeftMargin TopEdge LineLeft.i TopEdge
    if LineRight.i < CalRight then DrawLine 1 LineRight.i TopEdge CalRight TopEdge
  end
  LinePrefs LINECOLOR GridColor
  DrawLine 1 LineLeft.i TopEdge LineRight.i TopEdge
end

/* Create month/year header  */
TextBlockTypePrefs SIZE MonthFSize WIDTH MonthFWidth COLOR MonthFColor FONT MonthFont
DrawTextBlock 1 LeftMargin (TopMargin + (TextArea + MonthFontHeight)/3) upper(Month.Month" "Year); Month_obj = RESULT

/* Create weekday titles */
TextBlockTypePrefs SIZE WeekdayFSize WIDTH WeekdayFWidth COLOR WeekdayFColor FONT WeekdayFont
Do i = 0 to 6
  DrawTextBlock 1 1 1 upper(Day.i); text_obj.i = RESULT
End

Redraw

/* Position month/year header */
GetObjectCoords Month_obj; Parse Var result . . TextBottom TextWidth TextHeight
TextLeft = (LeftMargin + (PageWidth - TextWidth)/2)
SetObjectCoords Month_obj 1 TextLeft TextBottom TextWidth TextHeight

/* Position weekday titles */
TextBottom = CalTop - WeekdayFontHeight * .45
Do i = 0 to 6
  GetObjectCoords text_obj.i; Parse Var result . . . TextWidth TextHeight
  BoxCenter = (LeftMargin + (i * BoxWidth) + BoxWidth/2)
  TextLeft = (BoxCenter - TextWidth/2)
  SetObjectCoords text_obj.i 1 TextLeft TextBottom TextWidth TextHeight
End

if DoMiniCals = 1 then do
  BoxPrefs LINEWT None FILL Solid FILLCOLOR HighlightColorNB
  TextBlockTypePrefs SIZE MiniCalFSize COLOR MiniCalFColor FONT DateFont
  BoxPrefs LINEWT Hairline LINECOLOR MiniCalBColor
  if symbol('MiniCalColor') == 'VAR' then BoxPrefs FILL Solid FILLCOLOR MiniCalColor
  else BoxPrefs FILL Transparent
  DrawTextBlock 1 1 1 "1"; ID = RESULT
  Redraw
  GetObjectCoords ID; parse var RESULT . . . WidthOf1 .
  DeleteObject ID

  call DrawMiniCal(-1, MiniCalWidth, MiniCalFontHeight)
  call DrawMiniCal(+1, MiniCalWidth, MiniCalFontHeight)
end

SelectObject
View 75

if upper(DecimalFormat) = 'COMMA' then DocItemPrefs Decimal Comma
exit

/*******  ConvertMonth Subroutine  ***********/
ConvertMonth: PROCEDURE EXPOSE Month. AbbrMonth.
  parse arg Month
  MonthNumber = 0
  if Datatype(Month) == upper('char') then
    do i = 1 to 12
      If upper(Month) == upper(Month.i) Then do; MonthNumber = i; leave; end
      If upper(Month) == upper(AbbrMonth.i) Then do; MonthNumber = i; leave; end
    end
  else MonthNumber = Month
  if MonthNumber < 1 | MonthNumber > 12 then MonthNumber = 0
  return MonthNumber

/*******  SetHighlights Subroutine  ***********/
SetHighlights:
say "Setting highlights for "mn year
  if exists(Pragma(D)'/FWMacros/FWCalendar.data') then do
    call open(DataFile, Pragma(D)'/FWMacros/FWCalendar.data')
      call seek(DataFile, HighlightStart, B)
      do until eof(DataFile)
        Ln = ReadLn(DataFile)
        if left(Ln, 2) == Mn then interpret substr(Ln, 3)
      end
    call close(DataFile)
  end
return

/*******  CalculateDate Subroutine  ***********/
CalculateDate:
/* Month    is the month in which the highlight occurs                        */
/* HighDate is the highest (numerical) date on which the highlight will occur */
/* HighDay  is the weekday on which HighDate will occur                       */
/* Event    is the highlight text                                             */
parse arg GD_Month, GD_HighDay, GD_HighDate, GD_Event

interpret 'GD_HighDay = Day.'GD_HighDay
interpret 'GD_First = Day.'Date(W, Year''right(GD_Month, 2, '0')'01', S)

GD_Day = GD_HighDate + (GD_HighDay - GD_First)
if GD_First < GD_HighDay then GD_Day = GD_Day - 7
Highlight.GD_Month.GD_Day = GD_Event
return 0

/*******  DrawMiniCal Subroutine  ***********/
DrawMiniCal:
  parse arg MiniDirection, CalWidth, FHeight

  BoxCount = 0
  MiniMonth = Month + MiniDirection
  if MiniMonth == 0 | MiniMonth == 13 then do
    MiniMonth = abs(MiniMonth - 12)
    Year = EnteredYear + MiniDirection
  end
  Mn = right(MiniMonth, 2, '0')
  call SetHighlights

  if MiniDirection < 0 then do
    StartColumn = StartDate - MonthLength.MiniMonth//7
    If StartColumn < 0 then StartColumn = StartColumn + 7
    MiniCalLeft = LeftMargin + CalWidth/28
  end
  else if MiniDirection > 0 then do
    StartColumn = StartDate + MonthLength.Month//7
    If StartColumn > 6 then StartColumn = StartColumn - 7
    MiniCalLeft = FullWidth - RightMargin - CalWidth
  end
  else do
    StartColumn = StartDate
    MiniCalLeft = LeftMargin + c * (CalWidth + MiniCalHSpacing)
  end

  DrawTextBlock 1 1 (TopMargin + FHeight) Month.MiniMonth" "Year; ID.0 = RESULT
  Redraw
  GetObjectCoords ID.0; Parse var RESULT . . Top CurrentWidth Height
  SetObjectCoords ID.0 1 (MiniCalLeft - CalWidth/28+ (CalWidth - CurrentWidth)/2) Top CurrentWidth Height
  Column = StartColumn
  Day = 0
  Row = 2
  Do Until Day = MonthLength.MiniMonth
    Day = Day + 1

    if symbol('Highlight.MiniMonth.Day') == 'VAR' Then TextBlockTypePrefs FONT DateFontBold
    else TextBlockTypePrefs FONT DateFont

    If Day < 10 then Do
      DrawTextBlock 1 (MiniCalLeft+Column*CalWidth/7 + WidthOf1) (TopMargin + Row*FHeight) Day; ID.Day = RESULT
    End
    else Do
      DrawTextBlock 1 (MiniCalLeft+Column*CalWidth/7) (TopMargin + Row*FHeight) Day; ID.Day = RESULT
    End
    if right(Highlight.MiniMonth.Day, 1) == '#' then do
      BoxCount = BoxCount + 1
      GetObjectCoords ID.Day; parse var result . Left Top CurrentWidth Height
      DrawBox 1 Left (Top - .8 * Height) CurrentWidth Height; BoxID.BoxCount = result
      ObjectToBack
    end
    Column = Column + 1
    if Column == 7 then Do
      Column = 0
      Row = Row + 1
    End
  End
  Rows = trunc((StartColumn + MonthLength.MiniMonth)/7) + 1.5
  if (StartColumn + MonthLength.MiniMonth)//7 > 0 then Rows = Rows + 1
  If CalType == 2 then Rows = 7.5
  DrawBox 1 (MiniCalLeft - CalWidth/28) TopMargin CalWidth (Rows*FHeight)
  ObjectToBack
  Redraw
  do i = 0 to MonthLength.MiniMonth; SelectObject ID.i MULTIPLE; End
  do i = 1 to BoxCount; SelectObject BoxID.i MULTIPLE; End
  Group
  TextBlockTypePrefs FONT DateFont
return

/*******  SetVariable Subroutine  ***********/
SetVariables:
  GetPageSetup Width Height Top Bottom Left Right
  parse var result FullWidth FullHeight TopMargin BottomMargin LeftMargin RightMargin

  WhiteName =      'White'
  BlackName =      'Black'

  if exists(Pragma(D)'/FWMacros/FWCalendar.data') then do
    call open(DataFile, Pragma(D)'/FWMacros/FWCalendar.data')
      VarCount = 0
      do until eof(DataFile)
        Ln = ReadLn(DataFile)
        if (upper(word(Ln, 1)) == 'WHITENAME') | (upper(word(Ln, 1)) == 'BLACKNAME') then do
          interpret Ln
          VarCount = VarCount + 1
        end
        if VarCount == 2 then leave
      end
    call close(DataFile)
  end

  DoMiniCals       = 1
/*  MiniCalColor     = 'Red' */
  MiniCalBColor    = BlackName
  MiniCalFColor    = BlackName

  Extended         = 1
  ExtendedColor    = 'Cyan'
  GridColor        = BlackName

/*  WeekendColor     = 'Cyan' */

  MonthFont        = "FONTS:Nimbus-Q/Serif/Dragon"
  MonthFSize       = 44
  MonthFWidth      = 100
  MonthFColor      = BlackName

  WeekdayFont      = "FONTS:Nimbus-Q/Serif/Dragon"
  WeekdayFSize     = 22
  WeekdayFWidth    = 100
  WeekdayFColor    = BlackName

  DateFont         = "SoftSans"
  DateFontBold     = "SoftSans_Bold"
  DateFSize        = 10
  DateFWidth       = 100
  DateFColor       = BlackName

  HighlightFSize   = 8
  HighlightFColorNB= BlackName
  HighlightFColorB = BlackName
/*  HighlightColorNB = WhiteName */
/*  HighlightColorB  = WhiteName */

  MiniCalFSize     = 8
  MiniCalHSpacing  = 0.05
  MiniCalVSpacing  = 0.1

  Day.0 = 'Sunday'
  Day.1 = 'Monday'
  Day.2 = 'Tuesday'
  Day.3 = 'Wednesday'
  Day.4 = 'Thursday'
  Day.5 = 'Friday'
  Day.6 = 'Saturday'

  Month.1  = 'January'
  Month.2  = 'February'
  Month.3  = 'March'
  Month.4  = 'April'
  Month.5  = 'May'
  Month.6  = 'June'
  Month.7  = 'July'
  Month.8  = 'August'
  Month.9  = 'September'
  Month.10 = 'October'
  Month.11 = 'November'
  Month.12 = 'December'

  AbbrMonth.1  = 'Jan'
  AbbrMonth.2  = 'Feb'
  AbbrMonth.3  = 'Mar'
  AbbrMonth.4  = 'Apr'
  AbbrMonth.5  = 'May'
  AbbrMonth.6  = 'Jun'
  AbbrMonth.7  = 'Jul'
  AbbrMonth.8  = 'Aug'
  AbbrMonth.9  = 'Sep'
  AbbrMonth.10 = 'Oct'
  AbbrMonth.11 = 'Nov'
  AbbrMonth.12 = 'Dec'

  MonthLength.1    = 31
  MonthLength.2    = 28
  MonthLength.3    = 31
  MonthLength.4    = 30
  MonthLength.5    = 31
  MonthLength.6    = 30
  MonthLength.7    = 31
  MonthLength.8    = 31
  MonthLength.9    = 30
  MonthLength.10   = 31
  MonthLength.11   = 30
  MonthLength.12   = 31

  Day.Sunday    = 0
  Day.Monday    = 1
  Day.Tuesday   = 2
  Day.Wednesday = 3
  Day.Thursday  = 4
  Day.Friday    = 5
  Day.Saturday  = 6

  if exists(Pragma(D)'/FWMacros/FWCalendar.data') then do
    call open(DataFile, Pragma(D)'/FWMacros/FWCalendar.data')
      do until eof(DataFile)
        Ln = ReadLn(DataFile)
        if left(Ln, 15) == '/* End Pass One' then do
          HighlightStart = seek(DataFile, 0)
          leave
        end
        interpret Ln
      end
    call close(DataFile)
  end

  GetDisplayPrefs Measure; Units = result
  select
    when Units = 'Inches' then PointsPerUnit = 72
    when Units = 'Metric' then PointsPerUnit = 28.34645669291
    when Units = 'Pica' then   PointsPerUnit = 12
  end

  MonthFontHeight     = MonthFSize / PointsPerUnit
  WeekdayFontHeight   = WeekdayFSize / PointsPerUnit
  DateFontHeight      = DateFSize / PointsPerUnit
  HighlightFontHeight = HighlightFSize / PointsPerUnit
  MiniCalFontHeight   = MiniCalFSize / PointsPerUnit

  PageWidth  = FullWidth - LeftMargin - RightMargin
  PageHeight = FullHeight - TopMargin - BottomMargin
  TextArea   = 2.1 * MonthFontHeight
  BoxWidth   = PageWidth/7
  BoxHeight  = (PageHeight-TextArea)/5
  CalTop     = TopMargin + TextArea
  CalRight   = LeftMargin + BoxWidth * 7

  Margins = TopMargin'|'BottomMargin'|'LeftMargin'|'RightMargin'|'TextArea

  DateDown        = DateFontHeight
  DateOffset      = 3.6 / PointsPerUnit
  HighlightOffset = 14.4 / PointsPerUnit
  MiniCalWidth    = 108 / PointsPerUnit

  FYMiniCalWidth      = PageWidth/3
  FYMiniCalFontHeight = PageHeight/31
  FYMiniCalFSize      = trunc(FYMiniCalFontHeight * PointsPerUnit)

  ThisMonth = left(date('U'), 2) + 0
  TextBlockPrefs TEXTFLOW None

  if TestMode = 1 then call TestSettings
return

TestSettings:
  ErrorCount = 0
  ErrorString = ''

  FontVariable.1 = 'MonthFont';   Font.1 = MonthFont
  FontVariable.2 = 'WeekdayFont'; Font.2 = WeekdayFont
  FontVariable.3 = 'DateFont';    Font.3 = DateFont
  FontVariable.4 = 'DateFontBold';Font.4 = DateFontBold
  Do i = 1 to 4
    Font Font.i
    type i
    status FontPath; CurrentFont = result
    if NameOnly(Font.i) ~= NameOnly(CurrentFont) then do
      ErrorCount = ErrorCount + 1
      ErrorString = ErrorString||'0a'x||'   'FontVariable.i
    end
  end

  ColorName.1 = 'WhiteName';          Color.1 = WhiteName
  ColorName.2 = 'BlackName';          Color.2 =  BlackName
  ColorName.3 = 'MiniCalColor';       Color.3  = MiniCalColor
  ColorName.4 = 'MiniCalBColor';      Color.4  = MiniCalBColor
  ColorName.5 = 'MiniCalFColor';      Color.5  = MiniCalFColor
  ColorName.6 = 'ExtendedColor';      Color.6  = ExtendedColor
  ColorName.7 = 'GridColor';          Color.7  = GridColor
  ColorName.8 = 'WeekendColor';       Color.8  = WeekendColor
  ColorName.9 = 'MonthFColor';        Color.9  = MonthFColor
  ColorName.10 = 'DateFColor';        Color.10 = DateFColor
  ColorName.11 = 'HighlightFColorNB'; Color.11 = HighlightFColorNB
  ColorName.12 = 'HighlightFColorB';  Color.12 = HighlightFColorB
  ColorName.13 = 'HighlightColorNB';  Color.13 = HighlightColorNB
  ColorName.14 = 'HighlightColorB';   Color.14 = HighlightColorB
  do j = 1 to 14
    if symbol(ColorName.j) == 'VAR' then do
      FontColor Color.j
      type i + j
      status FontColor; CurrentColor = result
      if CurrentColor ~= Color.j then do
        ErrorCount = ErrorCount + 1
        ErrorString = ErrorString||'0a'x||'   'ColorName.j
      end
    end
  end

  SelectAll; Clear

  if ErrorCount ~= 0 then do
    ErrorString = 'The following variable(s) are not properly defined:'||ErrorString
    call rtezrequest(ErrorString)
  end
return

NameOnly:
  parse arg fontname

  lastcolon = LastPos(':', fontname)
  lastslash = lastpos('/', fontname)
  return substr(fontname, max(lastcolon, lastslash) + 1)